perm filename ALAID.SAI[AL,HE]11 blob
sn#379973 filedate 1978-09-12 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00015 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 COMMENT: Switches, source file requirements
C00004 00003 ! HN recent modifications
C00005 00004 ! Data structures
C00008 00005 ! ALAIDINIT, PEEK, POKE, PEEKARRAY, POKEARRAY
C00018 00006 ! GETNOTE, SNDNOTE, SNDN1
C00022 00007 ! LINKBUF, SAMELTH, UNLBUF
C00024 00008 ! ASCIFY, NUMERIFY, SENDSTRING
C00028 00009 ! WORD, KTABLE, KLOOKUP
C00033 00010 ! Symbol table primitives: ADDSYM, GETSYM, SYM_TO_LEVOFS
C00036 00011 ! QUEUE primitives: LINKQUE, UNLQUE, SAMEID
C00038 00012 ! SERVER
C00045 00013 ! ASKELF
C00047 00014 ! TREATREQUEST
C00055 00015 ! Bugs
C00056 ENDMK
C⊗;
COMMENT: Switches, source file requirements;
IFCR ¬DECLARATION(EXTENDED_COMPILATION)
THENC
DEFINE EXTENDED_COMPILATION = "TRUE";
ENTRY;
BEGIN "alaid"
COMMENT: Source file requirements;
REQUIRE "ABBREV.SAI[AL,HE]" SOURCE_FILE;
DEFINE RPTR = "RECORD_POINTER";
DEFINE RNULL = "NULL_RECORD";
DEFINE $$PRGID "[]" = ["ALAID"];
PROCEDURE COMERR
(STRING MESSG;RECORD_POINTER(ANY_CLASS) CONTXT (NULL_RECORD));
! Non-fatal warnings;
BEGIN
USERERR(0,1,"HAH! "&MESSG);
END;
ENDC;
! HN recent modifications ;
INTERNAL STRING FILALS; ! HN Saving the *.als file name for DEBAL ;
BOOLEAN TIMEOUT_FLAG; ! To be set when timeout (for 11's response) is desired ;
BOOLEAN TIMED;
DEFINE TIMEOUT_DEFAULT = 50 ;
INTEGER TIMEOUT_LIMIT;
DEFINE TIMEOUT = '777 ;
! Data structures;
RECORD_CLASS BUFFER (INTEGER LTH, ADR; RPTR (BUFFER) NEXT, PREV;
INTEGER ARRAY MSG; STRING SMSG);
RPTR(BUFFER) BUFGOT;
! List of buffers allocated by 11 for us. The LTH, ADR fields set up;
RPTR(BUFFER) BUFNEED;
! List of messages we want to send to 11. The LTH, MSG fields set up;
RPTR(BUFFER) BUFRECD;
! List of messages sent from the 11. The LTH, MSG, SMSG fields set up;
RECORD_CLASS QUEUE
(ITEMVAR WAITER; INTEGER ID; STRING ANSWER; RPTR(QUEUE) PREV, NEXT);
RPTR(QUEUE) WAITQUEUE;
! Notes from 10 to 11;
DEFINE GETBUF = '1;
DEFINE USEBUF = '2;
DEFINE RELBUF = '3;
! Notes from 11 to 10;
DEFINE BUFALC = '101;
DEFINE TAKBUF = '102;
! Offsets in message buffers;
DEFINE MESID = 0;
DEFINE MESTYP = 2;
DEFINE FROMTEN = '1;
DEFINE FROMELF = '2;
DEFINE REQUEST = '4;
DEFINE RESPONSE = '10;
DEFINE MESLTH = 4;
DEFINE MESBEG = 6;
INTEGER MSGNO; ! Always even, numbers the last message originating at the 10;
DEFINE MAP_OFFSET = "'320000"; ! Converts virtual addresses to physical ones;
DEFINE NOTB10 = "'160000"; ! The notebox from 11 to the 10 (byte address);
DEFINE NOTB11 = "'160020"; ! The notebox from 10 to the 11 (byte address);
DEFINE NOTSIZ = "3"; ! In WORDS!;
DEFINE OUTTST = "OUTSTR";
! DEFINE OUTTST = "! ";
INTEGER BRCHAR; ! Break character;
INTEGER WTABL0; ! Break table;
INTEGER WTABL1; ! Break table;
INTEGER WTABL2; ! Break table;
INTEGER WTABL3; ! Break table;
INTEGER WTABL4; ! Break table;
! Sources:;
DEFINE USER = 1;
DEFINE ELFIE = 2;
! Process macros;
DEFINE SUSPHIM="'10",
SUSPME="'2",
RUNME="'1",
READYME="'4";
REQUIRE 30 NEW_ITEMS;
ITEM DUMMYITEM; ! Used for resumes. Never use the datum!!;
! ALAIDINIT, PEEK, POKE, PEEKARRAY, POKEARRAY;
INTEGER ELFCHAN; ! Channel number for I/O to ELF;
FORWARD PROCEDURE SERVER;
FORWARD PROCEDURE ADDSYM(STRING SYM; INTEGER LEVOFS);
INTERNAL PROCEDURE ALAIDINIT;
BEGIN "init"
INTEGER COUNT, BRCHAR, EOF, FLAG;
OWN BOOLEAN ONCE; comment INITIALIZE(ONCE←FALSE);
! Only allow one initialization;
IF ONCE
THEN BEGIN
COMERR("ALAIDINIT called more than once; it initializes itself now.");
RETURN
END
ELSE ONCE ← TRUE;
! Initialize the ELF for output;
ELFCHAN ← GETCHAN;
OPEN(ELFCHAN,"ELF",'17,0,0,COUNT,BRCHAR,EOF);
! Initialize the buffer chains;
BUFGOT ← NEW_RECORD(BUFFER);
BUFNEED ← NEW_RECORD(BUFFER);
BUFRECD ← NEW_RECORD(BUFFER);
! Initialize the queue chains;
WAITQUEUE ← NEW_RECORD(QUEUE);
! Initialize the break tables;
WTABL0← GETBREAK;
WTABL1← GETBREAK;
WTABL2← GETBREAK;
WTABL3← GETBREAK;
WTABL4← GETBREAK;
SETBREAK(WTABL0,'175,'15,"ISK"); ! Stop at alt;
SETBREAK(WTABL1," ()+-"&'12&'11,'15,"IRK"); ! Stop at delimiter, retain;
SETBREAK(WTABL2," ",NULL,"XR"); ! Stop at space or alt;
SETBREAK(WTABL3,'11&'12&'15,'11&'12&'15,"XR"); ! Skip <cr>, <lf> and <tab>;
SETBREAK(WTABL4,".",NULL,"IS"); ! Skip to and through period;
! Initialize the symbol table;
ADDSYM("$B0.BARM",'2);
ADDSYM("$B0.BHAND",'3);
! Intialize the timeout limit;
TIMEOUT_LIMIT← TIMEOUT_DEFAULT;
! Start up one copy of SERVER;
SPROUT(NEW,SERVER,RUNME);
END "init";
REQUIRE ALAIDINIT INITIALIZATION[0];
DEFINE MTAPE = "'072000";
INTEGER PROCEDURE PEEK(INTEGER ADR);
BEGIN "peek" ! Returns the ELF word at unibus address ADR;
DEFINE PEEK = "'002000000000";
LABEL PEK1, PEKMTA, PEK3, PEK4, PEK5;
INTEGER ANS, ADR1;
! INTEGER TEMP;
ADR1 ← ADR;
START_CODE;
MOVE 1,ADR1 ; ! Prepare MTAPE data in PEK1;
LSH 1,-1 ;
HRRM 1,PEK1 ;
MOVE 1,ELFCHAN ; ! Prepare MTAPE in PEKMTA;
LSH 1,5 ;
ADDI 1,MTAPE ;
HRLM 1,PEKMTA ;
PEKMTA:
PEK1 ; ! This will become MTAPE ELFCHAN,PEK1;
JRST PEK3 ; ! Error;
JRST PEK4 ; ! OK;
PEK1:
PEEK ;
PEK5:
0 ;
PEK3:
SETOM PEK5 ; ! Error result;
PEK4:
MOVE 1,PEK5 ;
MOVEM 1,ANS ;
END;
IF ANS = -1 THEN COMERR("Couldn't peek at ELF.");
! IF ANS = -1 THEN begin
! temp←getsts(elfchan);
! COMERR("Couldn't peek at ELF. GETSTS="&cvos(temp));
! end;
RETURN(ANS);
END "peek";
PROCEDURE POKE(INTEGER ADR, CONTENTS);
BEGIN "poke" ! Stores CONTENTS at unibus address ADR;
DEFINE POKE = "'003000000000";
LABEL POK1, POKMTA, POK3, POK4, POK5;
INTEGER ANS, ADR1, CNTS;
ADR1 ← ADR;
CNTS ← CONTENTS;
START_CODE;
MOVE 1,ADR1 ; ! Prepare MTAPE data in POK1;
LSH 1,-1 ;
HRRM 1,POK1 ;
MOVE 1,ELFCHAN ; ! Prepare MTAPE in POKMTA;
LSH 1,5 ;
ADDI 1,MTAPE ;
HRLM 1,POKMTA ;
MOVE 1,CNTS ;
MOVEM 1,POK5 ;
POKMTA:
POK1 ; ! This will become MTAPE ELFCHAN,POK1;
JRST POK3 ; ! Error;
JRST POK4 ; ! OK;
POK1:
POKE ;
POK5:
0 ;
POK3:
SETOM POK5 ; ! Error result;
POK4:
MOVE 1,POK5 ;
MOVEM 1,ANS ;
END;
IF ANS = -1 THEN COMERR("Couldn't poke at ELF");
RETURN;
END "poke";
PROCEDURE POKEARRAY(INTEGER ADR, LTH; INTEGER ARRAY CONTENTS);
BEGIN "pokearray" ! Sends the CONTENTS[0:LTH-1] to unibus address ADR
and higher;
INTEGER ADR1, LTH1, CNTS;
LABEL SND1, SND4, SNDUST, SNDIOW, SNDOUT;
DEFINE USETO = "'075000";
DEFINE OUT = "'057000";
ADR1 ← ADR + MAP_OFFSET;
CNTS ← LOCATION(CONTENTS[0]);
LTH1 ← LTH;
START_CODE;
MOVE 1,ADR1 ; ! Prepare USETO data in SND1;
LSH 1,-1 ;
ADDI 1,'400000 ;
HRRM 1,SND1 ;
MOVE 1,ELFCHAN ; ! Prepare USETO in SNDUST;
LSH 1,5 ;
ADDI 1,USETO ;
HRLM 1,SNDUST ;
SNDUST:
SND1 ; ! This will become USETO ELFCHAN,SND1;
JRST SND4 ; ! OK;
SND1:
'400000000000 ; ! one word transfer, don't grab unibus;
SNDIOW:
0 ; ! Will be IOWD [LTH,CNTS];
SND4:
MOVN 1,LTH1 ; ! Prepare IOWD in SNDIOW;
HRLZM 1,SNDIOW ;
MOVE 1,CNTS ;
SUBI 1,1 ;
HRRM 1,SNDIOW ;
MOVE 1,ELFCHAN ; ! Prepare OUT in SNDOUT;
LSH 1,5 ;
ADDI 1,OUT ;
HRLM 1,SNDOUT ;
SNDOUT:
SNDIOW ; ! This will become OUT ELFCHAN,SNDIOW;
SETZ 1, ; ! Success return;
MOVEM 1,ADR1 ; ! Failure return;
END;
IF ADR1 ≠ 0 THEN COMERR("POKEARRAY failed");
RETURN;
END "pokearray";
PROCEDURE PEEKARRAY(INTEGER ADR, LTH; INTEGER ARRAY CONTENTS);
BEGIN "peekarray" ! Gets the CONTENTS[0:LTH-1] from unibus address ADR
and higher;
INTEGER ADR1, LTH1, CNTS;
LABEL GET1, GET4, GETUST, GETIOW, GETIN;
DEFINE USETI = "'074000";
DEFINE IN = "'056000";
ADR1 ← ADR + MAP_OFFSET;
CNTS ← LOCATION(CONTENTS[0]);
LTH1 ← LTH;
START_CODE;
MOVE 1,ADR1 ; ! Prepare USETI data in GET1;
LSH 1,-1 ;
ADDI 1,'400000 ;
HRRM 1,GET1 ;
MOVE 1,ELFCHAN ; ! Prepare USETI in GETUST;
LSH 1,5 ;
ADDI 1,USETI ;
HRLM 1,GETUST ;
GETUST:
GET1 ; ! This will become USETI ELFCHAN,GET1;
JRST GET4 ; ! OK;
GET1:
'400000000000 ; ! one word transfer, don't grab unibus;
GETIOW:
0 ; ! Will be IOWD [LTH,CNTS];
GET4:
MOVN 1,LTH1 ; ! Prepare IOWD in GETIOW;
HRLZM 1,GETIOW ;
MOVE 1,CNTS ;
SUBI 1,1 ;
HRRM 1,GETIOW ;
MOVE 1,ELFCHAN ; ! Prepare IN in GETIN;
LSH 1,5 ;
ADDI 1,IN ;
HRLM 1,GETIN ;
GETIN:
GETIOW ; ! This will become IN ELFCHAN,GETIOW;
SETZ 1, ; ! Success return;
MOVEM 1,ADR1 ; ! Failure return;
END;
IF ADR1 ≠ 0 THEN COMERR("PEEKARRAY failed");
RETURN;
END "peekarray";
! GETNOTE, SNDNOTE, SNDN1;
DEFINE SLEEP = "'047040000031"; ! The SLEEP UUO;
INTEGER TCOUNT;
PROCEDURE GETNOTE (INTEGER ARRAY NOTE);
BEGIN "getnote"
! Listens to the notebox from the 11 and returns the note when it
arrives, in array NOTE[0:NOTSIZ-1];
TCOUNT← 0;
WHILE TRUE DO
BEGIN "gwaiting"
INTEGER SGNAL, I;
SGNAL ← PEEK(NOTB10);
IF SGNAL = 0
THEN
IF TCOUNT ≥ TIMEOUT_LIMIT AND TIMED
THEN BEGIN
NOTE[0] ← TIMEOUT;
TIMEOUT_FLAG← TRUE;
RETURN
END
ELSE
BEGIN "count"
IF TIMED THEN TCOUNT← TCOUNT+1; ! HN for timout detection ;
START_CODE "gnotyet"
MOVEI 1,0 ;
SLEEP ; ! Sleep for a tick;
END "gnotyet"
END "count"
ELSE BEGIN "ggotit"
NOTE[0] ← SGNAL;
FOR I ← 1 STEP 1 UNTIL NOTSIZ-1 DO
NOTE[I] ← PEEK(NOTB10+I+I);
OUTTST(CRLF & "Receiving note: " & CVOS(SGNAL));
POKE(NOTB10,0); ! Clear the note;
RETURN;
END "ggotit";
END "gwaiting";
END "getnote";
PROCEDURE SNDNOTE (INTEGER ARRAY NOTE);
BEGIN "sndnote"
! Sends the note in NOTE[0:NOTSIZ-1] to the 11's notebox as soon
as it is free;
TCOUNT← 0;
WHILE TRUE DO
BEGIN "swaiting"
INTEGER SGNAL, I;
SGNAL ← PEEK(NOTB11);
IF SGNAL ≠ 0
THEN IF TCOUNT ≥ TIMEOUT_LIMIT AND TIMED
THEN BEGIN
TIMEOUT_FLAG← TRUE;
RETURN
END
ELSE BEGIN
IF TIMED THEN TCOUNT← TCOUNT+1;! HN for timout detection ;
START_CODE "snotyet"
MOVEI 1,0 ;
SLEEP ; ! Sleep for a tick;
END "snotyet"
END
ELSE BEGIN "sgotit"
FOR I ← 1 STEP 1 UNTIL NOTSIZ-1 DO
POKE(NOTB11+I+I,NOTE[I]);
POKE(NOTB11,NOTE[0]); ! Set the note's appearance;
RETURN;
END "sgotit"
END "swaiting";
END "sndnote";
PROCEDURE SNDN1(INTEGER ARG0, ARG1 (0), ARG2 (0));
BEGIN "sndn1"
! A little note is to be sent. Send it;
INTEGER ARRAY LNOTE [0:NOTSIZ-1];
LNOTE[0] ← ARG0;
OUTTST(CRLF & "Sending note: " & CVOS(ARG0));
LNOTE[1] ← ARG1;
LNOTE[2] ← ARG2;
SNDNOTE(LNOTE);
END "sndn1";
! LINKBUF, SAMELTH, UNLBUF;
! There is currently no interlocking here, and there ought to be some;
PROCEDURE LINKBUF(RPTR(BUFFER) NEW, HEAD);
BEGIN "linkbuf"
! There is always a dummy buffer at the start of the chain. Put
the NEW one after it;
BUFFER:NEXT[NEW] ← BUFFER:NEXT[HEAD];
BUFFER:PREV[NEW] ← HEAD;
BUFFER:NEXT[HEAD] ← NEW;
END "linkbuf";
RPTR(BUFFER) PROCEDURE UNLBUF(RPTR(BUFFER) OLD);
BEGIN "unlbuf"
! Returns OLD, which is unlinked from its list;
BUFFER:NEXT[BUFFER:PREV[OLD]] ← BUFFER:NEXT[OLD];
IF BUFFER:NEXT[OLD] ≠ RNULL THEN
BUFFER:PREV[BUFFER:NEXT[OLD]] ← BUFFER:PREV[OLD];
RETURN(OLD);
END "unlbuf";
RPTR(BUFFER) PROCEDURE SAMELTH(RPTR(BUFFER) HEAD; INTEGER LTH);
BEGIN "samelth"
! Remove and return a buffer from the list at HEAD having the
same length as LTH. If none is found, return RNULL;
RPTR(BUFFER) PTR;
PTR ← BUFFER:NEXT[HEAD]; ! Since first one is a dummy;
WHILE PTR ≠ RNULL DO
IF BUFFER:LTH[PTR] = LTH
THEN RETURN(UNLBUF(PTR))
ELSE PTR ← BUFFER:NEXT[PTR];
RETURN(RNULL);
END "samelth";
! ASCIFY, NUMERIFY, SENDSTRING;
STRING PROCEDURE ASCIFY (INTEGER ARRAY MSG; INTEGER LTH);
BEGIN "ascify"
! Converts the 11-format ASCIZ string to 10-format;
STRING ANS;
INTEGER PTR;
ANS ← NULL;
FOR PTR ← 3 STEP 1 UNTIL LTH-1 DO ! Skip header words;
BEGIN "unpack" ! Take care of two characters;
ANS ← ANS & (MSG[PTR] LAND '377) & (MSG[PTR] LSH -8);
END "unpack";
RETURN(ANS);
END "ascify";
PROCEDURE NUMERIFY (INTEGER ARRAY MSG; STRING STR);
BEGIN "numerify"
! Converts the 10-format ASCIZ string to 11-format;
INTEGER MPTR, SPTR, MLTH;
IF LENGTH(STR) LAND 1 THEN STR ← STR & " "; ! Make length even;
MLTH ← (LENGTH(STR) % 2) + 3;
SPTR ← 1;
OUTTST(CRLF & "Numerified: ");
FOR MPTR ← 3 STEP 1 UNTIL MLTH-1 DO ! Skip header words;
BEGIN "pack" ! Take care of two characters;
MSG[MPTR] ← STR[SPTR FOR 1] + (STR[SPTR+1 FOR 1] LSH 8);
OUTTST(" " & CVOS(MSG[MPTR]));
SPTR ← SPTR + 2;
END "pack";
END "numerify";
PROCEDURE SENDSTRING(STRING STR; INTEGER MESGNO, MESGTYP);
BEGIN "sendstring"
! Sends the string as a message, with the header words set up to
look like a message of MESGTYP (ie FROMTEN + (REQUEST | RESPONSE);
RPTR(BUFFER) BUF;
INTEGER AA, LTH;
BUF ← NEW_RECORD(BUFFER);
BUFFER:LTH[BUF] ← LTH ← LENGTH(STR) + 4; ! Extra for header words;
BUFFER:SMSG[BUF] ← STR;
BEGIN ! Make a new message array;
INTEGER ARRAY MSG [0:LTH-1];
AA ← MEMLOC(MSG,INTEGER);
MEMLOC(MSG,INTEGER) ← 0; ! Defeats deallocation;
END;
MEMLOC(BUFFER:MSG[BUF],INTEGER) ← AA;
NUMERIFY(BUFFER:MSG[BUF],STR);
BUFFER:MSG[BUF][MESID % 2] ← MESGNO;
BUFFER:MSG[BUF][MESTYP % 2] ← FROMTEN + MESGTYP;
BUFFER:MSG[BUF][MESLTH % 2] ← LTH;
LINKBUF(BUF,BUFNEED);
SNDN1(GETBUF,LTH);
END "sendstring";
! WORD, KTABLE, KLOOKUP;
STRING PROCEDURE WORD(REFERENCE STRING STR);
BEGIN "word"
! Takes the first word off of STR and returns it;
INTEGER BRCHAR;
STRING ANS;
ANS ← SCAN(STR,WTABL1,BRCHAR); ! Take till a delimiter;
SCAN(STR,WTABL2,BRCHAR); ! Remove leading spaces;
RETURN(ANS);
END "word";
DEFINE KTLIMIT = 0;
DEFINE KWORD(MNE,XXX) "<>" = <
REDEFINE KTLIMIT=KTLIMIT+1;
ASSIGNC XXX = CVPS(MNE)&"_KTYPE";
DEFINE XXX = KTLIMIT;
"MNE">;
PRELOAD_WITH
! Commands that the ELF must treat;
KWORD(GETVAL), ! Retrieve value;
KWORD(SETVAL), ! Set value;
KWORD(SIGNAL), ! Cause a signal on the ELF;
KWORD(WAIT), ! Cause a wait on the ELF;
KWORD(START), ! Start up an interpreter;
KWORD(DDT), ! Switch to DDT on the ELF;
KWORD(NOTICE), ! Assume that the arms have moved by manual intervention;
KWORD(HALT), ! Halt all interpreters ;
KWORD(SHOW), ! Show the current IPC and its content;
KWORD(PUT), ! PUT <pcode> AT <address>;
KWORD(BREAK), ! Set break_point;
KWORD(UNBREAK), ! Clear (delete) break_point;
KWORD(JUMP), ! Jump current interpreter to the address argument ;
KWORD(GO), ! GO i.e. put back all HALTed interpreters on the runway;
KWORD(STEP), ! Execute one pseudo_instruction (single stepping) ;
! Commands that the TEN must treat;
KWORD(YOUTHERE), ! Used for testing only right now;
KWORD(SYMBOLS), ! Get symbol file;
KWORD(TIMEOUT), ! Set the timeout limit;
! Intermediate forms;
KWORD(OFFSET), ! What follows is an octal level-offset;
KWORD(NAME); ! What follows is a symbolic name;
OWN STRING ARRAY KTABLE[1:KTLIMIT];
INTEGER PROCEDURE KLOOKUP(REFERENCE STRING STR, KEYWORD);
BEGIN "klookup"
! STR is a user input. We assume it has some keyword at its
head, and arguments after. We return a numeric code
corresponding to the keyword, and lop the keyword off the string.
;
INTEGER PTR, SUBPTR;
KEYWORD ← WORD(STR);
OUTTST(CRLF & "KEYWORD = " & KEYWORD);
FOR PTR ← 1 STEP 1 UNTIL KTLIMIT DO
BEGIN "search"
IF KTABLE[PTR] = KEYWORD
THEN BEGIN "ssearch"
FOR SUBPTR ← 2 STEP 1 UNTIL LENGTH(KTABLE[PTR]) MIN LENGTH(KEYWORD) DO
IF KTABLE[PTR][SUBPTR FOR 1] ≠ KEYWORD[SUBPTR FOR 1]
THEN CONTINUE "search";
RETURN(PTR);
END "ssearch";
END "search";
RETURN(0); ! Couldn't find it;
END "klookup";
! Symbol table primitives: ADDSYM, GETSYM, SYM_TO_LEVOFS;
! The symbol table is a pairing of names and level-offsets.
Eventually, the pairing should also include interpreters, but for now
the way it is done is this: To associate $B1.FOO with offset 36,
there is an item whose print name is FOO, and whose datum is 36.
Block names are ignored.;
PROCEDURE ADDSYM(STRING SYM; INTEGER LEVOFS);
BEGIN "addsym"
INTEGER BRCHAR;
SCAN(SYM,WTABL4,BRCHAR); ! Strip off the block name;
NEW_PNAME(NEW(LEVOFS),SYM);
END "addsym";
INTEGER PROCEDURE GETSYM(STRING SYM);
BEGIN "getsym"
INTEGER FLAG, ANS;
INTEGER ITEMVAR DUMMYITEM;
ANS ← DATUM(DUMMYITEM ← CVSI(SYM,FLAG));
IF FLAG THEN ANS ← 0;
RETURN(ANS);
END "getsym";
BOOLEAN PROCEDURE SYM_TO_LEVOFS(REFERENCE STRING ARG, ANS);
BEGIN "s2l"
! ARG is a string, either of the form "(SYMBOL foo)" or of the
form "(OFFSET foo)". If the ARG is of the first form, an attempt
is made to cast it into the second form. If this fails, return
FALSE. If already in second form, return TRUE. In any case,
return whatever was possible in ANS, and the rest of ARG is untouhced;
STRING STEMP, SDUMMY;
INTEGER LEVOFS, ITEMP;
ANS ← STEMP ← ARG;
SCAN(STEMP,WTABL1,BRCHAR); ! Remove leading spaces;
IF LOP(STEMP) ≠ "(" THEN RETURN(FALSE);
ITEMP ← KLOOKUP(STEMP,SDUMMY);
IF ITEMP = OFFSET_KTYPE
THEN BEGIN
ARG ← NULL;
RETURN(TRUE);
END;
IF ITEMP ≠ NAME_KTYPE THEN RETURN(FALSE);
LEVOFS ← GETSYM(WORD(STEMP));
SDUMMY ← LOP(STEMP);
IF LEVOFS = 0 THEN RETURN(FALSE);
ANS ← "(OFFSET " & CVOS(LEVOFS) & ")";
ARG ← STEMP;
RETURN(TRUE);
END "s2l";
! QUEUE primitives: LINKQUE, UNLQUE, SAMEID;
! There is currently no interlocking here, and there ought to be some;
PROCEDURE LINKQUE(RPTR(QUEUE) NEW, HEAD);
BEGIN "linkque"
! There is always a dummy queue at the start of the chain. Put
the NEW one after it;
QUEUE:NEXT[NEW] ← QUEUE:NEXT[HEAD];
QUEUE:PREV[NEW] ← HEAD;
QUEUE:NEXT[HEAD] ← NEW;
END "linkque";
RPTR(QUEUE) PROCEDURE UNLQUE(RPTR(QUEUE) OLD);
BEGIN "unlque"
! Returns OLD, which is unlinked from its list;
QUEUE:NEXT[QUEUE:PREV[OLD]] ← QUEUE:NEXT[OLD];
IF QUEUE:NEXT[OLD] ≠ RNULL THEN
QUEUE:PREV[QUEUE:NEXT[OLD]] ← QUEUE:PREV[OLD];
RETURN(OLD);
END "unlque";
RPTR(QUEUE) PROCEDURE SAMEID(RPTR(QUEUE) HEAD; INTEGER ID);
BEGIN "sameid"
! Remove and return a QUEUE from the list at HEAD having the
same id as ID. If none is found, return RNULL;
RPTR(QUEUE) PTR;
PTR ← QUEUE:NEXT[HEAD]; ! Since first one is a dummy;
WHILE PTR ≠ RNULL DO
IF QUEUE:ID[PTR] = ID
THEN RETURN(UNLQUE(PTR))
ELSE PTR ← QUEUE:NEXT[PTR];
RETURN(RNULL);
END "sameid";
! SERVER;
FORWARD INTERNAL RECURSIVE STRING PROCEDURE TREATREQUEST
(STRING STR; INTEGER SOURCE);
PROCEDURE SERVER;
! Listens to notes from the 11 and acts on them. This procedure
is instantiated as a process and never returns. The 11 interface
(ELF) can interrupt the 10 thru the user interrupt system. Bit
20 (0,,100000) (called INTELF) is the relevent bit to enable. ;
BEGIN "server"
DEFINE PSTACK(X)="(X LSH 8)";
DEFINE STRINGSTACK(X) = "(X LSH 14)";
SPROUT_DEFAULTS PSTACK(4) + STRINGSTACK(2);
INTEGER ARRAY SNOTE [0:NOTSIZ-1];
WHILE TRUE DO BEGIN
GETNOTE(SNOTE);
CASE SNOTE[0] OF
BEGIN
[BUFALC]
BEGIN "bufalc"
! The 11 has allocated a buffer we asked for to send a message;
INTEGER LTH, ADR;
RPTR(BUFFER) BUF;
LTH ← SNOTE[1];
ADR ← SNOTE[2];
BUF ← SAMELTH(BUFNEED,LTH);
IF BUF = RNULL
THEN BEGIN ! We didn't need it;
BUF ← NEW_RECORD(BUFFER);
BUFFER:LTH[BUF] ← SNOTE[1];
BUFFER:ADR[BUF] ← ADR;
LINKBUF(BUF,BUFGOT);
END
ELSE BEGIN ! We were expecting it;
BUFFER:ADR[BUF] ← ADR;
POKEARRAY(ADR,LTH,BUFFER:MSG[BUF]);
OUTTST(CRLF & "Sending buffer to: " & CVOS(ADR));
SNDN1(USEBUF,ADR);
END;
END "bufalc";
[TAKBUF]
BEGIN "takbuf"
INTEGER LTH, AA;
RPTR(BUFFER) BUF;
BUF ← NEW_RECORD(BUFFER);
LTH ← PEEK(SNOTE[1] + MESLTH + MAP_OFFSET);
BEGIN ! Make a new message array;
INTEGER ARRAY MSG [0:LTH-1];
AA ← MEMLOC(MSG,INTEGER);
MEMLOC(MSG,INTEGER) ← 0; ! Defeats deallocation;
END;
MEMLOC(BUFFER:MSG[BUF],INTEGER) ← AA;
BUFFER:LTH[BUF] ← LTH;
PEEKARRAY(SNOTE[1],LTH,BUFFER:MSG[BUF]);
BUFFER:SMSG[BUF] ← ASCIFY(BUFFER:MSG[BUF],LTH);
OUTTST(CRLF & "Got buffer: " & BUFFER:SMSG[BUF]);
SNDN1(RELBUF,SNOTE[1]);
IF BUFFER:MSG[BUF][MESTYP % 2] LAND RESPONSE THEN
BEGIN "response"
RPTR(QUEUE) Q;
Q ← SAMEID(WAITQUEUE,BUFFER:MSG[BUF][MESID % 2]);
IF Q = RNULL
THEN COMERR("Got an unexpected answer from ELF")
ELSE BEGIN "wakeup"
QUEUE:ANSWER[Q] ← BUFFER:SMSG[BUF];
RESUME(QUEUE:WAITER[Q],DUMMYITEM,READYME);
END "wakeup";
END "response"
ELSE
BEGIN "request"
SPROUT(NEW,
SENDSTRING(
TREATREQUEST(BUFFER:SMSG[BUF],ELFIE),
BUFFER:MSG[BUF][MESID % 2],
RESPONSE
)
);
END "request";
END "takbuf";
[TIMEOUT]
BEGIN "timeout"
! HN This is not a real message... it has come from GETNOTE
describing a timeout situation. We assume (!!) that the last quary
from 10 is the last item in the queue therefore we delete that
item and resume the (askelf) proces associated to it. ;
RPTR(QUEUE) Q;
RPTR(BUFFER) BUFF;
INTEGER I;
Q← QUEUE:NEXT[WAITQUEUE]; ! Since first one is a dummy;
IF Q = RNULL THEN USERERR(0,0,"TIMEOUT BUG. SEND A MESSAGE TO HN");
! See if there is an associated item in the buffer list
to be deleted;
I← QUEUE:ID[UNLQUE(Q)];
BUFF← BUFFER:NEXT[BUFNEED]; ! Since first one is a dummy;
WHILE BUFF ≠ RNULL DO
IF BUFFER:MSG [BUFF] [MESID % 2] = I
THEN UNLBUF(BUFF)
ELSE BUFF← BUFFER:NEXT[BUFF];
QUEUE:ANSWER[Q]←"TIMEOUT ... 11 partner doesn't respond";
RESUME(QUEUE:WAITER[Q],DUMMYITEM,READYME);
END "timeout";
[0] COMERR("Can't interpret NOTE" & CVOS(SNOTE[0]))
END ! of case statement;
END ! of while statement;
END "server";
! ASKELF;
STRING PROCEDURE ASKELF(STRING ARG);
BEGIN "askelf"
! The ARG is to be sent as a message to the ELF, and we are to
wait until there is a response, which is to be directed back to
the caller;
RPTR(QUEUE) Q;
Q ← NEW_RECORD(QUEUE);
QUEUE:ID[Q] ← MSGNO ← MSGNO + 2;
QUEUE:WAITER[Q] ← MYPROC;
LINKQUE(Q,WAITQUEUE);
TIMED← TRUE; ! Yes. WE ARE WAITING FOR AN ANSWER !! ;
SENDSTRING(ARG,QUEUE:ID[Q],REQUEST);
IF TIMEOUT_FLAG THEN BEGIN
TIMEOUT_FLAG← FALSE;
UNLQUE(Q);
RETURN("TIMEOUT ... 11 partner doesn't want to listen !");
END;
SUSPEND(MYPROC);
! The SERVER will notice when an answer comes, and will reawaken
us then, having removed us from the WAITQUEUE. ;
TIMED← FALSE; ! No more waiting ;
RETURN(QUEUE:ANSWER[Q]);
END "askelf";
! TREATREQUEST;
INTERNAL RECURSIVE STRING PROCEDURE TREATREQUEST
(STRING STR; INTEGER SOURCE);
BEGIN "treatrequest"
! A request, STR, has come from a SOURCE (user, elf, outside).
If it came from the ELF, we cannot treat it. In the other cases,
we currently just send it to the ELF (not really trying to do
anything with it ourselves). ;
! P.S. (HN) In order to make everybody happy , we capitalize STR ;
STRING PROCEDURE CAPTAL(STRING S);
BEGIN
INTEGER I, L;
STRING SC, C;
L← LENGTH(S);
SC ← "";
FOR I←1 STEP 1 UNTIL L DO
BEGIN
C← S[I FOR 1];
IF (C ≥ '141) AND (C ≤ '172)
THEN SC ← SC & (C - '40)
ELSE SC ← SC & C
;
END
;
RETURN(SC);
END;
STRING KEY, ANS;
STR ← CAPTAL(STR);
IF SOURCE = ELFIE
THEN CASE KLOOKUP(STR,KEY) OF
BEGIN "trtelf"
[YOUTHERE_KTYPE]
BEGIN "youthere"
OUTTST(CRLF & "Question from ELF: " & KEY & STR);
ANS ← "SURE I'M HERE, WHERE ELSE WOULD I BE?";
END "youthere";
[0] COMERR("Can't make sense out of: " & KEY & STR)
END "trtelf"
ELSE CASE KLOOKUP(STR,KEY) OF
BEGIN "trtuser"
[GETVAL_KTYPE]
BEGIN "getval"
STRING LVOFSTR;
OUTTST(CRLF & KEY & " " & STR);
IF ¬SYM_TO_LEVOFS(STR,LVOFSTR)
THEN COMERR("Unknown symbol: " & STR)
ELSE ANS ← ASKELF("GETVAL " & LVOFSTR & STR);
END "getval";
[SETVAL_KTYPE]
BEGIN "setval"
STRING LVOFSTR;
OUTTST(CRLF & KEY & " " & STR);
IF ¬SYM_TO_LEVOFS(STR,LVOFSTR)
THEN COMERR("Unknown symbol: " & STR)
ELSE ANS ← ASKELF("SETVAL " & LVOFSTR & STR);
END "setval";
[WAIT_KTYPE]
BEGIN "wait"
STRING LVOFSTR;
OUTTST(CRLF & KEY & " " & STR);
IF ¬SYM_TO_LEVOFS(STR,LVOFSTR)
THEN COMERR("Unknown symbol: " & STR)
ELSE ANS ← ASKELF("WAIT " & LVOFSTR & STR);
END "wait";
[SIGNAL_KTYPE]
BEGIN "signal"
STRING LVOFSTR;
OUTTST(CRLF & KEY & " " & STR);
IF ¬SYM_TO_LEVOFS(STR,LVOFSTR)
THEN COMERR("Unknown symbol: " & STR)
ELSE ANS ← ASKELF("SIGNAL " & LVOFSTR & STR);
END "signal";
[START_KTYPE]
BEGIN "start"
OUTTST(CRLF & KEY & " " & STR);
ANS ← ASKELF("START " & STR);
END "start";
[DDT_KTYPE]
BEGIN "ddt"
OUTTST(CRLF & KEY & " " & STR);
ANS ← ASKELF("DDT " & STR);
END "ddt";
[NOTICE_KTYPE]
BEGIN "notice"
OUTTST(CRLF & KEY & " " & STR);
ANS ← ASKELF("NOTICE " & STR);
END "notice";
[HALT_KTYPE]
BEGIN "halt"
OUTTST(CRLF & KEY & " " & STR);
ANS ← ASKELF("HALT " & STR);
END "halt" ;
[SHOW_KTYPE]
BEGIN "Show"
OUTTST (CRLF & KEY & " " & STR) ;
ANS ← ASKELF ( "SHOW " & STR ) ;
END "Show" ;
[PUT_KTYPE]
BEGIN "put"
OUTTST (CRLF & KEY & " " & STR) ;
ANS ← ASKELF ( "PUT " & STR ) ;
END "put" ;
[BREAK_KTYPE]
BEGIN "break"
OUTTST (CRLF & KEY & " " & STR) ;
ANS ← ASKELF ("BREAK " & STR);
END "break";
[UNBREAK_KTYPE]
BEGIN "unbreak"
OUTTST (CRLF & KEY & " " & STR) ;
ANS ← ASKELF ("UNBRK " & STR);
END "unbreak";
[JUMP_KTYPE]
BEGIN "jump"
OUTTST(CRLF & KEY & " " & STR);
ANS ← ASKELF("JUMP " & STR);
END "jump";
[GO_KTYPE]
BEGIN "GO"
OUTTST(CRLF & KEY & " " & STR);
ANS ← ASKELF("GO " & STR);
END "GO";
[STEP_KTYPE]
BEGIN "Step"
OUTTST(CRLF & KEY & " " & STR);
ANS ← ASKELF("STEP " & STR);
END "Step";
[SYMBOLS_KTYPE]
BEGIN "symbols"
STRING FILNAM, SYM;
INTEGER FILCHAN, COUNT, BRCHAR, EOF, LEVOFSET, FLAG;
OUTTST(CRLF & KEY & " " & STR);
! Open the file for input of symbols;
FILCHAN ← GETCHAN;
COUNT ← 200;
OPEN(FILCHAN,"DSK",0,2,0,COUNT,BRCHAR,EOF);
FILNAM ← WORD(STR);
LOOKUP(FILCHAN,FILNAM,FLAG);
IF FLAG THEN RETURN("CANT")
ELSE FILALS ← FILNAM
; ! HN Saving the *.als file name for DEBAL ;
! The format for this file is:
name<tab>level-offset<crlf>
repeated until the end of file. Example:
$B1.F3 36
;
! Read in the symbols;
INPUT(FILCHAN,WTABL3); ! Skip <tab>;
SYM ← INPUT(FILCHAN,WTABL1); ! Stop at tab;
INPUT(FILCHAN,WTABL3); ! Skip <tab>;
WHILE ¬EOF DO
BEGIN "readsym"
LEVOFSET ← CVO(INPUT(FILCHAN,WTABL1));
INPUT(FILCHAN,WTABL3); ! Skip <crlf>;
IF LENGTH(SYM)>3 THEN ADDSYM(SYM,LEVOFSET);
SYM ← INPUT(FILCHAN,WTABL1); ! Stop at tab;
INPUT(FILCHAN,WTABL3); ! Skip <tab>;
END "readsym";
RELEASE(FILCHAN);
ANS ← "DONE";
END "symbols";
[TIMEOUT_KTYPE]
BEGIN
INTEGER VAL,BRCHAR;
OUTTST(CRLF & KEY & " " & STR);
VAL← INTSCAN(STR,BRCHAR);
IF BRCHAR = -1
THEN ANS ← "TIMEOUT_LIMIT IS "&CVS(TIMEOUT_LIMIT)
ELSE BEGIN TIMEOUT_LIMIT← VAL; ANS ← "DONE" END;
END;
[0] COMERR("Can't make sense out of: " & KEY & STR)
END "trtuser";
RETURN(ANS);
END "treatrequest";
! Bugs
DDT command eventually returns with a pdl ov.
Should start off with BARM in symbol table.
;
END $$PRGID;